######################################################
# 认识对象
######################################################
# 定义类
setClass(
  "TimeSeries",
   representation(
     data = "numeric",
     start = "POSIXct",
     end = "POSIXct"
   )
)
# 定义校验
setValidity(
  "TimeSeries",
  function(object){
    object@start <= object@end &&
      length(object@start) == 1 &&
      length(object@end) == 1
  }
)
# 定义方法
period.TimeSeries <- function(object) {
  if(length(object@data) > 1){
    (object@end - object@start) / (length(object@data) - 1)
  }else{
    Inf
  }
}
getSeries <- function(object){object@data}
period <- function(object){object@period}
# 泛型函数，多态
setGeneric("period")
setGeneric("period.TimeSeries")
setMethod(period, signature = c("TimeSeries"), definition = period.TimeSeries)
period(my.TimeSeries)
showMethods("period.TimeSeries")
showMethods("period")
# 继承
setClass(
  "WeightHistory",
  representation(
    height = "numeric",
    name = "character"
  ),
  contains = "TimeSeries"
)
john.doe <- new("WeightHistory",
                data=c(170, 169, 168, 170),
                start = as.POSIXct("07/01/2009 0:00:00", tz = "GMT", 
                                   format = "%m/%d/%Y %H:%M:%S"),
                end = as.POSIXct("07/01/2009 0:05:00", tz = "GMT", 
                                 format = "%m/%d/%Y %H:%M:%S"),
                height = 72,
                name = "John Doe")
setClass(
  "Person",
  representation(
    height = "numeric",
    name = "character"
  )
)
setClass(
  "WeightHistory",
  contains = c("TimeSeries", "Person")
)
john.doe
# 类合并，虚类
setClass(
  "Cat",
  representation(
    breed = "character",
    name = "character"
  )
)
setClassUnion(
  "NameThing",
  c("Person", "Cat")
)

# 类实例化
my.TimeSeries <- new("TimeSeries",
                     data = c(1, 2, 3, 4, 5, 6),
                     start = as.POSIXct("07/01/2009 0:00:00", tz = "GMT", 
                                        format = "%m/%d/%Y %H:%M:%S"),
                     end = as.POSIXct("07/01/2009 0:05:00", tz = "GMT", 
                                      format = "%m/%d/%Y %H:%M:%S")
                     )
my.TimeSeries
# 手动校验
validObject(my.TimeSeries)
# 实例化时自动校验
my.TimeSeries <- new("TimeSeries",
                     data = c(1, 2, 3, 4, 5, 6),
                     start = as.POSIXct("07/01/2009 0:05:00", tz = "GMT", 
                                        format = "%m/%d/%Y %H:%M:%S"),
                     end = as.POSIXct("07/01/2009 0:10:00", tz = "GMT", 
                                      format = "%m/%d/%Y %H:%M:%S")
)
period.TimeSeries(my.TimeSeries)
getSeries(my.TimeSeries)
getSeries
setGeneric("getSeries")
getSeries
showMethods("getSeries")

######################################################
# 面向对象S4
######################################################

# eg
setClass("Shape",slots=list(name="character",shape="character"))
setClass("Ellipse",contains="Shape",slots=list(radius="numeric"),prototype=list(radius=c(1,1),shape="Ellipse"))
setClass("Circle",contains="Ellipse",slots=list(radius="numeric"),prototype=list(radius = 1,shape="Circle"))
setClass("Rectangle",contains="Shape",slots=list(edges="numeric"),prototype=list(edges=c(1,1),shape="Rectangle"))
setClass("Square",contains="Rectangle",slots=list(edges="numeric"),prototype=list(edges=1,shape="Square"))

setGeneric("getShape",function(obj,...) standardGeneric("getShape"))
setMethod("getShape","Shape",function(obj,...){
  cat(obj@shape,"\n")
})


setGeneric("area",function(obj,...) standardGeneric("area"))
setMethod("area","Ellipse",function(obj,...){
  cat("Ellipse Area :\n")
  pi * prod(obj@radius)
})
setMethod("area","Circle",function(obj,...){
  cat("Circle Area :\n")
  pi*obj@radius^2
})
setMethod("area","Rectangle",function(obj,...){
  cat("Rectangle Area :\n")
  prod(obj@edges)
})
setMethod("area","Square",function(obj,...){
  cat("Square Area :\n")
  obj@edges^2
})


setGeneric("circum",function(obj,...) standardGeneric("circum"))
setMethod("circum","Ellipse",function(obj,...){
  cat("Ellipse Circum :\n")
  2*pi*sqrt((obj@radius[1]^2+obj@radius[2]^2)/2)
})
setMethod("circum","Circle",function(obj,...){
  cat("Circle Circum :\n")
  2*pi*obj@radius
})
setMethod("circum","Rectangle",function(obj,...){
  cat("Rectangle Circum :\n")
  2*sum(obj@edges)
})
setMethod("circum","Square",function(obj,...){
  cat("Square Circum :\n")
  4*obj@edges
})

e1<-new("Ellipse",name="e1",radius=c(2,5))
c1<-new("Circle",name="c1",radius=2)

r1<-new("Rectangle",name="r1",edges=c(2,5))
s1<-new("Square",name="s1",edges=2)

r1@name <- "hello"
r1$name <- "hello"  #no method for assigning subsets of this S4 class

area(e1)
area(c1)
circum(e1)
circum(c1)

area(r1)
area(s1)
circum(r1)
circum(s1)

getShape(r1)


######################################################
# 面向对象S3
######################################################

# eg
# 用UseMethod()定义teacher泛型函数
teacher <- function(x, ...) UseMethod("teacher")
teacher.lecture <- function(x) print("讲课")
teacher.assignment <- function(x) print("布置作业")
teacher.correcting <- function(x) print("批改作业")
teacher.default<-function(x) print("你不是teacher")

#a<-'teacher'
#attr(a,'class') <- 'lecture'
a <- structure("a", class = c("lecture"))
teacher(a)
teacher()
methods(teacher)
methods(generic.function="teacher")
methods(class="lecture")

teacher.good <- function(x) {print("高级老师"); NextMethod()}
b <- structure("b", class = c("good", "lecture"))
teacher(b)


# 从上面对S3对象的介绍来看，S3对象并不是完全的面向对象实现，而是一种通过泛型函数模拟的面向对象的实现。
# S3使用起来简单，但在实际的面向对象编程过程中，当对象关系有一定的复杂度，S3对象所表达的意义就会变得不太清楚。
# S3封装的内部函数，可绕过泛型函数的检查，以直接被调用。
# S3参数的class属性，可以被任意设置，没有预处理的检查。
# S3参数，只能通过调用class属性进行函数调用，其他属性则不会被class()函数执行。
# S3参数的class属性有多个值时，调用时会按照程序赋值顺序来调用第一个合法的函数。
# 所以，S3只能R语言面向对象的一种简单的实现。

######################################################
# 面向对象RC
######################################################
# RC面向对象编程：http://blog.fens.me/r-class-rc/
Shape <- setRefClass(
  "Shape",
  fields = list(name = "character", shape = "character"),
  methods = list(
    getShape = function(...){
      cat(shape,"\n")
    }
  )
)
Ellipse <- setRefClass(
  "Ellipse",
  contains = "Shape",
  fields = list(radius="numeric"),
  methods = list(
    initialize = function(name = "ellipse", radius = c(1,1)){
      callSuper()
      name <<- name
      radius <<- radius
      shape <<- c("Ellipse")
    },
    area = function(){
      cat("Ellipse Area :\n")
      pi * prod(radius)
    },
    circum = function(){
      cat("Ellipse Circum :\n")
      2*pi*sqrt((radius[1]^2+radius[2]^2)/2)
    }
  )
)
Circle <- setRefClass(
  "Circle",
  contains = "Ellipse",
  methods = list(
    initialize = function(name = "circle", radius = 1){
      callSuper(name, radius)
      shape <<- c("Circle")
    },
    area = function(){
      cat("Circle Area :\n")
      pi * radius^2
    },
    circum = function(){
      cat("Circle Circum :\n")
      2*pi*radius
    }
  )
)
Rectangle <- setRefClass(
  "Rectangle",
  contains = "Shape",
  fields = list(edges="numeric"),
  methods = list(
    initialize = function(name = "rectangle", edges = c(1,1)){
      callSuper()
      name <<- name
      edges <<- edges
      shape <<- c("Rectangle")
    }
  )
)
Square <- setRefClass(
  "Square",
  contains = "Rectangle",
  methods = list(
    initialize = function(name = "square", edges = 1){
      callSuper(name, edges)
      shape <<- c("Square")
    }
  )
)

ellipse <- Ellipse$new()
circle <- Circle$new(name = "circle", radius = 1)
rectangle <- Rectangle$new(name = "rectangle", edges = c(1, 1))
square <- Square$new(name = "square", edges = 1)

ellipse$area()
rectangle$getShape()
ellipse$name
square$edges

shape <- Shape$new(name = "s", shape = "s")
square$name
square$shape
shape$getShape()

######################################################
# 面向对象R6
######################################################

# R6面向对象编程：http://blog.fens.me/r-class-r6/